home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / translate.scm < prev    next >
Encoding:
Text File  |  1991-06-21  |  5.7 KB  |  203 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; File translate.scm / Copyright (c) 1991 Jonathan Rees / See file COPYING
  3.  
  4. ;;;; Translation from Scheme to Common Lisp
  5.  
  6. ; TRANSLATE translates a single Scheme expression into Common Lisp.
  7.  
  8. (define (translate form env)
  9.   (with-target-package (program-env-package env)
  10.     (lambda ()
  11.       (translate-to-common-lisp (list form) env))))
  12.  
  13. ; Used by translate and translate-file
  14.  
  15. (define (translate-to-common-lisp forms env)
  16.   (prognify
  17.    (let recur ((forms forms))
  18.      (if (null? forms)
  19.      '()
  20.      (cons (with-uid-reset
  21.         (lambda ()
  22.           (let-fluid @free-variables '()
  23.             (lambda ()
  24.               (let ((node (alpha-top (car forms) env)))
  25.             (generate-top
  26.              node
  27.              (generation-env (fluid @free-variables))
  28.              (not (null? (cdr forms)))))))))
  29.            (recur (cdr forms)))))))
  30.  
  31. ; Used by SCHEME-COMPILE.
  32.  
  33. (define (translate-lambda form env)
  34.   (with-uid-reset
  35.    (lambda ()
  36.      (let-fluid @free-variables '()
  37.        (lambda ()
  38.      (let ((node (alpha-top form env)))
  39.        (if (lambda? node)
  40.            (generate-lambda-top
  41.           node
  42.           (generation-env (fluid @free-variables)))
  43.            (error "not a lambda expression" form))))))))
  44.  
  45. ; File transduction
  46.  
  47. (define (really-translate-file source-file-name
  48.                    translated-file-name
  49.                    program-env)
  50.   (let ((source-code (read-file source-file-name)))
  51.     (compiling-to-file
  52.       translated-file-name
  53.       (program-env-package program-env)
  54.       (lambda (port)
  55.     (display ";  from file " port)
  56.     (display (lisp:namestring (lisp:truename source-file-name)) port)
  57.     (newline port))
  58.       (lambda (port)
  59.     (for-each (lambda (form)
  60.             (write-flattened form port))
  61.           (translate-to-common-lisp source-code program-env))))))
  62.  
  63. ; The following generates a file CLOSED.PSO from the information we
  64. ; have on how to open-code the built-in procedures.
  65.  
  66. (define (write-closed-definitions module outfile)
  67.   (compiling-to-file outfile
  68.              (module-package module)
  69.              (lambda (port) port)
  70.              (lambda (port)
  71.                (write-closed-definitions-1 module port))))
  72.  
  73. (define (write-closed-definitions-1 module port)
  74.   (let ((package (module-package module))
  75.     (sig (module-signature module))
  76.     (env (module-program-env module)))
  77.     (write-form
  78.       `(lisp:export
  79.      (lisp:quote ,(map (lambda (name) (change-package name package))
  80.                (signature-names sig))))
  81.       port)
  82.     (let ((funs '())
  83.       (defs '()))
  84.       (let ((do-it
  85.          (lambda (name)
  86.            (let* ((den (program-env-lookup env name))
  87.               (info (get-integration den)))
  88.          (if info
  89.              (let ((sym (program-variable-cl-symbol den)))
  90.                (case (car info)
  91.              ((val)
  92.               (write-form `(lisp:locally
  93.                        (lisp:declare (lisp:special ,sym))
  94.                      (lisp:setq ,sym ,(cadr info)))
  95.                       port)
  96.               (write-form `(schi:set-function-from-value
  97.                         (lisp:quote ,sym))
  98.                       port))
  99.              ((fun)
  100.               (if (not (memq name '(car cdr))) ;kludge
  101.                   (set! funs (cons (list sym (cadr info))
  102.                            funs))))
  103.              ((pred)
  104.               (write-form
  105.                (case (if (null? (cddr info))
  106.                     'n
  107.                     (caddr info))
  108.                  ((1)
  109.                   `(lisp:defun ,sym (x)
  110.                  (schi:true? (,(cadr info) x))))
  111.                  ((2)
  112.                   `(lisp:defun ,sym (x y)
  113.                  (schi:true? (,(cadr info) x y))))
  114.                  (else
  115.                   `(lisp:defun ,sym (lisp:&rest x)
  116.                  (schi:true? (lisp:apply #',(cadr info)
  117.                              x)))))
  118.                port)
  119.               (set! defs (cons sym defs)))
  120.              ((subst lambda)
  121.               (write-form `(lisp:defun ,sym ,@(cdr info)) port)
  122.               (set! defs (cons sym defs)))
  123.              ((special) 0) ;don't generate any definition
  124.              (else
  125.               (error "peculiar built-in" info)))))))))
  126.     (for-each do-it (signature-names sig))
  127.     (for-each do-it (signature-aux-names sig)))
  128.       (write-form
  129.         `(lisp:mapc (lisp:function schi:set-value-from-function)
  130.             (lisp:quote ,(reverse defs)))
  131.     port)
  132.       (write-form
  133.         `(lisp:mapc #'(lisp:lambda (z)
  134.             (lisp:let ((our-sym (lisp:car z))
  135.                    (cl-sym (lisp:cadr z)))
  136.               (lisp:setf (lisp:symbol-function our-sym) 
  137.                      (lisp:symbol-function cl-sym))
  138.               (schi:set-value-from-function our-sym)))
  139.             (lisp:quote ,(reverse funs)))
  140.     port))))
  141.  
  142. ; Utilities
  143.  
  144. (define (with-target-package package thunk)
  145.   (let-fluid @target-package package
  146.     thunk))
  147.  
  148. (define (compiling-to-file outfile package write-message proc)
  149.   (let-fluid @translating-to-file? #t
  150.     (lambda ()
  151.       (with-target-package package
  152.     (lambda ()
  153.       (call-with-output-file outfile
  154.         (lambda (port)
  155.           (write-file-identification port)
  156.           (write-message port)
  157.           (newline port)
  158.           (display "(SCHI:BEGIN-TRANSLATED-FILE)" port)
  159.           (newline port)
  160.           ;; Now do the real work.
  161.           (proc port)
  162.           (newline port)
  163.           outfile)))))))
  164.  
  165. (define (write-file-identification port)
  166.   (newline)
  167.   (display "Writing ")
  168.   (display (lisp:namestring (lisp:truename port)))
  169.   (display "; -*- Mode: Lisp; Syntax: Common-Lisp; Package: " port)
  170.   (display (lisp:package-name (fluid @target-package)) port) ;Heuristic
  171.   (display "; -*-" port)
  172.   (newline port)
  173.   (newline port)
  174.   (display "; This file was generated by " port)
  175.   (display (translator-version) port)
  176.   (newline port)
  177.   (display ";  running in " port)
  178.   (display (scheme-implementation-version) port)
  179.   (newline port))
  180.  
  181. (define (write-flattened form port)
  182.   (cond ((not (pair? form))
  183.      (if (not (or (symbol? form)
  184.               (number? form)
  185.               (boolean? form)
  186.               (string? form)
  187.               (char? form)))
  188.          ;; Who knows, it might be important.
  189.          (write-form form port)))
  190.         ((eq? (car form) 'lisp:quote)
  191.      )                ;do nothing
  192.     ((eq? (car form) 'lisp:progn)
  193.      (for-each (lambda (form)
  194.              (write-flattened form port))
  195.            (cdr form)))
  196.     (else
  197.      (write-form form port))))
  198.  
  199. (define (write-form form port)
  200.   (write-pretty form port (fluid @target-package)))
  201.  
  202. ; (put 'lisp:defun 'scheme-indent-hook 2)
  203.